home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / repl.scm < prev    next >
Text File  |  1999-04-19  |  3KB  |  93 lines
  1. ; "repl.scm", read-eval-print-loop for Scheme
  2. ; Copyright (c) 1993, Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'dynamic-wind)
  21. (define (repl:quit) (slib:error "not in repl:repl"))
  22.  
  23. (define (repl:top-level repl:eval)
  24.   (repl:repl (lambda () (display "> ")
  25.              (force-output (current-output-port))
  26.              (read))
  27.          repl:eval
  28.          (lambda objs
  29.            (cond ((null? objs))
  30.              (else
  31.               (write (car objs))
  32.               (for-each (lambda (obj)
  33.                   (display " ;") (newline) (write obj))
  34.                 (cdr objs))))
  35.            (newline))))
  36.  
  37. (define (repl:repl repl:read repl:eval repl:print)
  38.   (let* ((old-quit repl:quit)
  39.      (old-error slib:error)
  40.      (old-eval slib:eval)
  41.      (old-load load)
  42.      (repl:load (lambda (<pathname>)
  43.               (call-with-input-file <pathname>
  44.             (lambda (port)
  45.               (let ((old-load-pathname *load-pathname*))
  46.                 (set! *load-pathname* <pathname>)
  47.                 (do ((o (read port) (read port)))
  48.                 ((eof-object? o))
  49.                   (repl:eval o))
  50.                 (set! *load-pathname* old-load-pathname))))))
  51.      (repl:restart #f)
  52.      (values? (provided? 'values))
  53.      (has-char-ready? (provided? 'char-ready?))
  54.      (repl:error (lambda args (require 'debug) (apply qpn args)
  55.                  (repl:restart #f))))
  56.     (dynamic-wind
  57.      (lambda ()
  58.        (set! load repl:load)
  59.        (set! slib:eval repl:eval)
  60.        (set! slib:error repl:error)
  61.        (set! repl:quit
  62.          (lambda () (let ((cont repl:restart))
  63.               (set! repl:restart #f)
  64.               (cont #t)))))
  65.      (lambda ()
  66.        (do () ((call-with-current-continuation
  67.         (lambda (cont)
  68.           (set! repl:restart cont)
  69.           (do ((obj (repl:read) (repl:read)))
  70.               ((eof-object? obj) (repl:quit))
  71.             (cond
  72.              (has-char-ready?
  73.               (let loop ()
  74.             (cond ((char-ready?)
  75.                    (let ((c (peek-char)))
  76.                  (cond
  77.                   ((eof-object? c))
  78.                   ((char=? #\newline c) (read-char))
  79.                   ((char-whitespace? c)
  80.                    (read-char) (loop))
  81.                   (else (newline)))))))))
  82.             (if values?
  83.             (call-with-values (lambda () (repl:eval obj))
  84.                       repl:print)
  85.             (repl:print (repl:eval obj)))))))))
  86.      (lambda () (cond (repl:restart
  87.                (display ">>ERROR<<") (newline)
  88.                (repl:restart #f)))
  89.          (set! load old-load)
  90.          (set! slib:eval old-eval)
  91.          (set! slib:error old-error)
  92.          (set! repl:quit old-quit)))))
  93.